home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tables / HEAP.f next >
Encoding:
Text File  |  1989-03-04  |  3.9 KB  |  122 lines
  1. C ----------------------------------------------------------------------
  2. C
  3. C       H I N I T   -   Heap Initialise
  4. C
  5. C       Heap Format: Array(1) contains the address of the first element
  6. C                       on the free list.
  7. C                    Array(2) contains the highest element used so far
  8. C                       (i.e. with *any* information written in).
  9. C
  10.  
  11.         SUBROUTINE HINIT(ARRAY,ASIZE)
  12.         INTEGER ASIZE,ARRAY(ASIZE)
  13.  
  14.         EXTERNAL ERROR
  15.  
  16.         IF (ASIZE.LT.3) CALL ERROR('HINIT: ARRAY TOO SMALL')
  17.         ARRAY(1)=3
  18.         ARRAY(2)=4
  19.         ARRAY(3)=ASIZE-2
  20.         ARRAY(4)=0
  21.  
  22.         END
  23. C ----------------------------------------------------------------------
  24. C
  25. C       H A L L O C   -   Heap: Allocate storage block
  26. C
  27. C       Storage block format:
  28. C           Array(HALLOC-1)=size of this block
  29. C           Array(HALLOC...HALLOC+BSIZE-1)=the block itself
  30. C
  31. C       Free-list block format:
  32. C           Array(FPTR)=size of this block
  33. C           Array(FPTR+1)=address of next block or zero
  34. C
  35.  
  36.         INTEGER FUNCTION HALLOC(ARRAY,BSIZE)
  37.         INTEGER ARRAY(*),BSIZE
  38.  
  39.         INTEGER FPTR,LAST
  40.  
  41.         FPTR=ARRAY(1)
  42.         LAST=1
  43.         IF (FPTR.EQ.0) CALL ERROR('HALLOC: FREE LIST EXHAUSTED')
  44.  100    IF (ARRAY(FPTR).GT.BSIZE) THEN
  45. C We found a free-list element big enough for this block
  46.             HALLOC=FPTR+1
  47.             IF (ARRAY(FPTR).LE.BSIZE+2) THEN
  48. C If exactly same size or one bigger ...
  49. C ... unlink this block from the freelist
  50.                 ARRAY(LAST)=ARRAY(FPTR+1)
  51. C ... update the "heaptop" variable
  52.                 ARRAY(2)=MAX(ARRAY(2),HALLOC+ARRAY(FPTR))
  53.             ELSE
  54. C No - Must split the freelist block into two, allocating the
  55. C lower part to the user ...
  56. C ... Make link to the free-list block we are about to create
  57.                 ARRAY(LAST)=FPTR+BSIZE+1
  58. C ... Make the new free-list block
  59.                 ARRAY(FPTR+BSIZE+1)=ARRAY(FPTR)-BSIZE-1
  60.                 ARRAY(FPTR+BSIZE+2)=ARRAY(FPTR+1)
  61. C ... Split off the storage block to return to the user
  62.                 ARRAY(FPTR)=BSIZE+1
  63. C ... Update the "heaptop" variable
  64.                 ARRAY(2)=MAX(ARRAY(2),FPTR+BSIZE+2)
  65.             END IF
  66.         ELSE
  67. C This free-list element not big enough for the user's request
  68.             LAST=FPTR+1
  69.             FPTR=ARRAY(LAST)
  70.             IF (FPTR.NE.0) GOTO 100
  71.             CALL ERROR('HALLOC: HEAP STORAGE EXHAUSTED/FRAGMENTED')
  72.         END IF
  73.  
  74.         END
  75. C ----------------------------------------------------------------------
  76. C
  77. C       H G E T 1   -   Heap: Get a single integer from storage
  78. C
  79. C       Note: This does not allocate a "size" entry, and so can never be
  80. C             released using HFREE (it is assumed that if the user calls
  81. C             this routine they know what they are doing).  This has the
  82. C             advantage (for single-word entries) of no overhead.
  83. C
  84.  
  85.         INTEGER FUNCTION HGET1(ARRAY)
  86.         INTEGER ARRAY(*)
  87.  
  88.         EXTERNAL ERROR
  89.  
  90.         IF (ARRAY(1).EQ.0) CALL ERROR('HGET1: FREE LIST EXHAUSTED')
  91.  
  92.         HGET1=ARRAY(1)
  93.         IF (ARRAY(ARRAY(1)).EQ.2) THEN
  94. C This free-list entry is already at the minimum size, so we must use up
  95. C the whole 2 elements and delete it.
  96.             ARRAY(1)=ARRAY(ARRAY(1)+1)
  97.         ELSE
  98. C Steal a word from the front of this entry
  99.             ARRAY(ARRAY(1)+2)=ARRAY(ARRAY(1)+1)
  100.             ARRAY(ARRAY(1)+1)=ARRAY(ARRAY(1))-1
  101.             ARRAY(1)=ARRAY(1)+1
  102.             IF (ARRAY(2).LT.ARRAY(1)+1) ARRAY(2)=ARRAY(1)+1
  103.         END IF
  104.  
  105.         END
  106. C ----------------------------------------------------------------------
  107. C
  108. C       H F R E E   -   Heap: Free a storage block
  109. C
  110.  
  111.         SUBROUTINE HFREE(ARRAY,ELT)
  112.         INTEGER ARRAY(*),ELT
  113.  
  114. C This is simple - just create a new free-list block from the storage
  115. C block and put it onto the front of the free-list; this makes the
  116. C free-list function somewhat like a stack (but only somewhat).
  117.  
  118.         ARRAY(ELT)=ARRAY(1)
  119.         ARRAY(1)=ELT-1
  120.  
  121.         END
  122.